home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / CodeWarrior interface / example.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-12-13  |  3.9 KB  |  196 lines  |  [TEXT/MMCC]
  1. #include "lisp.h"
  2. #include "loader.h"
  3.  
  4. /*
  5.     When you set project preferences, you should
  6.     fill in the dialog fields in the following way:
  7.     
  8.     Project Type  -> 'Code Resource'
  9.     Code Resource Info:
  10.         File Name     -> The name of your resource file (as expected by DEFCMODULE)
  11.         Sym Name      -> As you wish
  12.         Resource name -> The name of your module (as expected by DEFCMODULE)
  13.         Header Type   -> 'Standard'
  14.     Multi-Segment  -> Checked        ResType  ResId
  15.     Display Dialog -> As you wish        'TCCD'     Any
  16.     Merge to File  -> As you wish        Creator  Type
  17.                         Any      Any
  18.     
  19.     Resource Flags:  Locked
  20. */
  21.  
  22. /*
  23.     CodeWarrior returns long values in D0 and pointers
  24.     in A0 which is fine for MCL.
  25. */
  26.  
  27. /*
  28.     When MCL passes a Lisp object, it passes a pointer to it.
  29.     That's why you need to use the GET macro to get to the actual Lisp object.
  30.     
  31.     MCL's fixnums are shifted by 3 bits (we say they are boxed).
  32.     That's why you need to use to UNBOX macro to get the actual value.
  33.     
  34.     When you return a value (in D0), you don't need to BOX it first, as MCL
  35.     will do it for you when your FF-CALL exits.
  36. */
  37.  
  38. long testFixnum (long ptr)
  39. {
  40.     return(UNBOX(GET(ptr)) + 1);
  41. }
  42.  
  43. long testCharacter (long ptr)
  44. {
  45.     switch (CHARACTER(GET(ptr))) {
  46.         case 'a': return 1; break;
  47.         case 'b': return 2; break;
  48.         case 'c': return 3; break;
  49.         default:  return 4;
  50.     }
  51. }
  52.  
  53. void testList (long ptr)
  54. {
  55.     long list = GET(ptr);
  56.  
  57.     CAR(list) += 8;
  58.     CDR(list) = CDR(CDR(list));
  59. }
  60.  
  61. struct foo {
  62.     long a, b, c;
  63. };
  64.  
  65. void testStruct (long ptr)
  66. {
  67.     struct foo *s = STRUCTURE(GET(ptr),foo);
  68.     
  69.     /*
  70.         As we are playing behind MCL's back, we need to BOX our integers.
  71.     */
  72.  
  73.     s->a += BOX(1);
  74.     s->b += BOX(2);
  75.     s->c += BOX(3);
  76. }
  77.  
  78. /*
  79.     Passing multi-dimentionnal arrays to C would be
  80.     very awkward because MCL implements multi-dimentionnal
  81.     arrays as displaced arrays.
  82. */
  83.  
  84. void testVector (long ptr)
  85. {
  86.     int i;
  87.     long *vec = VECTOR(GET(ptr));
  88.  
  89.     for(i=0; i<5; i++) {
  90.         vec[i] += BOX(i);
  91.     }
  92. }
  93.  
  94. /*
  95.     A string is simply a vector of characters,
  96.     each one taking one byte of memory.
  97. */
  98.  
  99. void testString (long ptr)
  100. {
  101.     int i;
  102.     char *str = STRING(GET(ptr));
  103.     
  104.     for(i=0; i<STRING_SIZE(GET(ptr)); i++) {
  105.         if (str[i] == 'a')
  106.             str[i] = 'A';
  107.     }
  108. }
  109.  
  110. void testShortDouble (long ptr)
  111. {
  112.     short double *x = FLOAT(GET(ptr));
  113.     *x = *x + 1.2;
  114. }
  115. /*
  116.     I leave it to someone else to figure out long doubles - RGP
  117. */
  118.  
  119. /*
  120.     If you allocate your structures 'a la' C, then your C code
  121.     becomes very nice and efficient (but see the THOUGHTS file for drawbacks).
  122. */
  123.  
  124. struct myStruct {
  125.     long a, b, c;
  126. };
  127.  
  128. void testCStructures (struct myStruct *ptr)
  129. {
  130.     ptr->c += ptr->a + ptr->b;
  131. }
  132.  
  133. /*
  134.     Unlike ThinkC, CW returns pointers via A0.
  135. */
  136.  
  137. void *testA0 (char *ptr)
  138. {
  139.     return (ptr+1);
  140. }
  141.  
  142. long testCallback (long ptr, void (*lispfn) ())
  143. {
  144.     (*lispfn) ();
  145.     return(UNBOX(CAR(GET(ptr))));
  146. }
  147.  
  148. long    myLong   = 11;
  149. short double  sd = 0.23;
  150. double    myDouble = 0.23;
  151.  
  152. long testGlobals ()
  153. {
  154.     return( myLong * myLong );
  155. }
  156.  
  157.  
  158. extern testMultiSegment();
  159.  
  160. void *testTraps()
  161. {
  162.     return NewPtr(12);
  163. }
  164.  
  165. /*
  166.     If the names match, the EXPORT macro returns the
  167.     address of the function    in the A0 register.
  168.  
  169.     If no EXPORT is successfull then the LOADER_ERROR
  170.     macro returns a NIL pointer in A0.
  171. */
  172.  
  173. void* main (unsigned char name[])
  174. {
  175.     LOADER_INIT(name);
  176.  
  177.     EXPORT(name, myLong,           "\pMY-LONG");
  178.     EXPORT(name, myDouble,         "\pMY-DOUBLE");
  179.     
  180.     EXPORT(name, testFixnum,       "\pTEST-FIXNUM");
  181.     EXPORT(name, testCharacter,    "\pTEST-CHARACTER");
  182.     EXPORT(name, testList,         "\pTEST-LIST");
  183.     EXPORT(name, testStruct,       "\pTEST-STRUCT");
  184.     EXPORT(name, testVector,       "\pTEST-VECTOR");
  185.     EXPORT(name, testString,       "\pTEST-STRING");
  186.     EXPORT(name, testShortDouble,  "\pTEST-SHORT-DOUBLE");
  187.     EXPORT(name, testCStructures,  "\pTEST-C-STRUCTURES");
  188.     EXPORT(name, testA0,           "\pTEST-A0");
  189.     EXPORT(name, testCallback,     "\pTEST-CALLBACK");
  190.     EXPORT(name, testGlobals,      "\pTEST-GLOBALS");
  191.     EXPORT(name, testMultiSegment, "\pTEST-MULTI-SEGMENT");
  192.     EXPORT(name, testTraps,        "\pTEST-TRAPS");
  193.  
  194.     LOADER_ERROR();
  195. }
  196.